home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / char.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  3.5 KB  |  137 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: char.lisp,v 1.13 91/11/09 02:37:38 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: char.lisp,v 1.13 91/11/09 02:37:38 wlott Exp $
  15. ;;; 
  16. ;;; This file contains the RT VM definition of character operations.
  17. ;;;
  18. ;;; Written by Rob MacLachlan
  19. ;;; Converted for the MIPS R2000 by Christopher Hoover.
  20. ;;;
  21. (in-package "MIPS")
  22.  
  23.  
  24.  
  25. ;;;; Moves and coercions:
  26.  
  27. ;;; Move a tagged char to an untagged representation.
  28. ;;;
  29. (define-vop (move-to-base-char)
  30.   (:args (x :scs (any-reg descriptor-reg)))
  31.   (:results (y :scs (base-char-reg)))
  32.   (:generator 1
  33.     (inst srl y x vm:type-bits)))
  34. ;;;
  35. (define-move-vop move-to-base-char :move
  36.   (any-reg descriptor-reg) (base-char-reg))
  37.  
  38.  
  39. ;;; Move an untagged char to a tagged representation.
  40. ;;;
  41. (define-vop (move-from-base-char)
  42.   (:args (x :scs (base-char-reg)))
  43.   (:results (y :scs (any-reg descriptor-reg)))
  44.   (:generator 1
  45.     (inst sll y x vm:type-bits)
  46.     (inst or y y vm:base-char-type)))
  47. ;;;
  48. (define-move-vop move-from-base-char :move
  49.   (base-char-reg) (any-reg descriptor-reg))
  50.  
  51. ;;; Move untagged base-char values.
  52. ;;;
  53. (define-vop (base-char-move)
  54.   (:args (x :target y
  55.         :scs (base-char-reg)
  56.         :load-if (not (location= x y))))
  57.   (:results (y :scs (base-char-reg)
  58.            :load-if (not (location= x y))))
  59.   (:effects)
  60.   (:affected)
  61.   (:generator 0
  62.     (move y x)))
  63. ;;;
  64. (define-move-vop base-char-move :move
  65.   (base-char-reg) (base-char-reg))
  66.  
  67.  
  68. ;;; Move untagged base-char arguments/return-values.
  69. ;;;
  70. (define-vop (move-base-char-argument)
  71.   (:args (x :target y
  72.         :scs (base-char-reg))
  73.      (fp :scs (any-reg)
  74.          :load-if (not (sc-is y base-char-reg))))
  75.   (:results (y))
  76.   (:generator 0
  77.     (sc-case y
  78.       (base-char-reg
  79.        (move y x))
  80.       (base-char-stack
  81.        (storew x fp (tn-offset y))))))
  82. ;;;
  83. (define-move-vop move-base-char-argument :move-argument
  84.   (any-reg base-char-reg) (base-char-reg))
  85.  
  86.  
  87. ;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
  88. ;;; to a descriptor passing location.
  89. ;;;
  90. (define-move-vop move-argument :move-argument
  91.   (base-char-reg) (any-reg descriptor-reg))
  92.  
  93.  
  94.  
  95. ;;;; Other operations:
  96.  
  97. (define-vop (char-code)
  98.   (:translate char-code)
  99.   (:policy :fast-safe)
  100.   (:args (ch :scs (base-char-reg) :target res))
  101.   (:arg-types base-char)
  102.   (:results (res :scs (any-reg)))
  103.   (:result-types positive-fixnum)
  104.   (:generator 1
  105.     (inst sll res ch 2)))
  106.  
  107. (define-vop (code-char)
  108.   (:translate code-char)
  109.   (:policy :fast-safe)
  110.   (:args (code :scs (any-reg) :target res))
  111.   (:arg-types positive-fixnum)
  112.   (:results (res :scs (base-char-reg)))
  113.   (:result-types base-char)
  114.   (:generator 1
  115.     (inst srl res code 2)))
  116.  
  117.  
  118. ;;; Comparison of base-chars.
  119. ;;;
  120. (define-vop (base-char-compare pointer-compare)
  121.   (:args (x :scs (base-char-reg))
  122.      (y :scs (base-char-reg)))
  123.   (:arg-types base-char base-char))
  124.  
  125. (define-vop (fast-char=/base-char base-char-compare)
  126.   (:translate char=)
  127.   (:variant :eq))
  128.  
  129. (define-vop (fast-char</base-char base-char-compare)
  130.   (:translate char<)
  131.   (:variant :lt))
  132.  
  133. (define-vop (fast-char>/base-char base-char-compare)
  134.   (:translate char>)
  135.   (:variant :gt))
  136.  
  137.